home *** CD-ROM | disk | FTP | other *** search
/ Mac Magazin/MacEasy 34 / Mac Magazin and MacEasy Magazine CD - Issue 34.iso / Grafik & Text / Alpha ƒ / Tcl / Modes / perl.tcl < prev    next >
Text File  |  1997-04-02  |  50KB  |  1,672 lines
  1. #############################################################################
  2. # MacPerl.tcl
  3. # -----------
  4. #
  5. # This is a set of routines that allow Alpha to act as a front end for the
  6. # standalone MacPerl application and that allow Perl scripts to be used as 
  7. # text filters in Alpha.  These functions are accessed through a special 
  8. # MacPerl menu.
  9. #
  10. # The features of this package are explained in the file "MacPerl Help",
  11. # accessible from the Help menu.
  12. #
  13. #############################################################################
  14. #
  15. # If you don't already have MacPerl, it's available by anonymous ftp from
  16. # the umich site
  17. #
  18. #   mac.archive.umich.edu    [141.211.165.34]    mac/development/languages
  19. #
  20. # and its mirrors.  Also, MacPerl's home site is 
  21. #
  22. #   ftp.switch.ch            [130.59.1.40]        software/mac/src/mpw_c
  23. #
  24. # MacPerl was written (ported to the Mac) by 
  25. #        Matthias Neeracher <neeri@iis.ee.ethz.ch> , and
  26. #        Tim Endres <time@ice.com>.
  27. #
  28. #############################################################################
  29. # Author: Tom Pollard <pollard@schrodinger.com>
  30. #
  31. # Contributors: Dan Herron     <herron@cogsci.ucsd.edu>
  32. #               David Schooley <schooley@ee.gatech.edu>
  33. #               Vince Darley   <vince@das.harvard.edu>
  34. #               Martijn Koster <m.koster@nexor.co.uk>
  35. #
  36. # Version History:
  37. #
  38. # 3.0  4/97  -  MacPerl interactions don't depend on MacPerl app name anymore
  39. #               Fixed bug with perlFileAsFilter ($scriptStart uninitialized)
  40. # 2.9  3/97  -  Fixed bug in command-dbl-click help lookup for Perl5 mode
  41. # 2.8  2/97  -  Added Quick-Save commands in new submenu [Dan Herron]
  42. #               "Save As CGI" finally works.
  43. # 2.7  2/97  -  Comments before "#!/bin/perl" no longer confuse 'gotoPerlError'
  44. # 2.6  2/97  -  Added electricPerlLeft and electricPerlRight - [David Schooley]
  45. # 2.51 1/96  -  Fixed problem w/ "Tell MacPerl:Save As..."
  46. # 2.5  1/96  -  Colorization and cmd-dbl-click modified to support Perl 5 docs
  47. # 2.41 7/95  -  Minor tweaks
  48. # 2.4  7/95  -  Fixed bugs affecting running unsaved scripts and error handling
  49. # 2.3  7/95  -  Minor tweaks and code rearrangement.
  50. # 2.2  6/95  -  Text filters act only on current line if "Apply to Buffer" is
  51. #                  false and no text has been selected.
  52. #               Bug fix in error-marking for scripts sent as AppleEvent params.
  53. #               Cmd-dbl-clicking a function call jumps to function, if
  54. #                  defined in the same file.
  55. # 2.1  6/95  -  Cmd-dbl-clicking a 'require'd filename opens the file.
  56. # 2.0  6/95  -  Minor bug fixes (incl. keyword decapitalization)
  57. #               Alpha 6.0b17 compatibility updates.
  58. #               Text Filters folder is settable from the App Paths menu now.
  59. # 1.9  5/95  -  Cmd-dbl-clicking Perl keywords and special variables displays
  60. #                  the man page info.
  61. # 1.81 4/95  -  one very minor Alpha compatibility update (winInfo->getWinInfo).
  62. # 1.8  4/95  -  Menu reorganized somewhat.
  63. #               Text Filters folder can now be anywhere.
  64. #               "ApplyToBuffer" flag ignored if text has been selected.
  65. #               Bug fixes.
  66. # 1.7  1/95  -  Updated to take advantage of MacPerl 4.1.4 AppleEvent features:
  67. #                1) Text filters use 'batch' doScript (.: STDOUT file obsolete)
  68. #                2) Filter scripts sent as doScript params (.: SCRIPT file obsolete)
  69. #                3) "Save As Droplet" and "Save as Runtime" commands added.
  70. #               Errors generated in 'require'd files are now displayed correctly
  71. # 1.6 10/94  -  "UseDebugger" flag added (forces scripts to run under debugger).
  72. #               Key bindings added for some menu commands.
  73. #               "perlDoScript{,2,3}" procs consolidated into a single proc.
  74. #               "saveAndRun" option added.
  75. #               Command-line args now parsed into units more correctly, in
  76. #                   particular, quoted file names aren't broken up.
  77. #               "Close Output Window" added to "Tell MacPerl" menu.
  78. #               Updated for Alpha 5.98 to load when menu is inserted.
  79. #               The error messages window is now recycled.
  80. #               "perlRecycleOutput" recycles output window.
  81. #               Minor bug fixes.
  82. # 1.5  9/94  -  MacPerl menu rearranged somewhat.
  83. #               Explicit "Get Output Window" command added to menu.
  84. #               Reading "#!" line for args is incompatible w/ standard,
  85. #                   so it's been dropped.
  86. #               Only scan the first 40 output lines for error messages (faster)
  87. #                "wrapFilterScript" no longer opens STDIN
  88. #               Text filters may now use command-line args
  89. #               STDIN for text filters passed as explicit cmd-line arg 
  90. # 1.4  9/94  -  The "#!" line of every script is read for command-line args,
  91. #                    which are passed explicitly to MacPerl with the script.
  92. #                "PromptForArgs" menu flag added.
  93. #                "perlCmdlineArgs" modeVar holds default command-line args.
  94. #                Scripts are sent using custom "perlDoScript2" proc, which
  95. #                    allows passing of explicit command-line args.
  96. # 1.3  9/94  -  When any script generates a compilation error, the file 
  97. #                    containing the script is brought up with the offending 
  98. #                    line highlighted; all error output is also written to
  99. #                    a "Perl Error Messages" window.
  100. #                'repeatLastFilter' runs again the last text-filter script used.
  101. #                'perlLastFilter' modeVar holds pathname of last filter.
  102. #                Menu flags now mirrored as modeVars, so they can be saved and
  103. #                    restored between sessions.
  104. #                Minor bug fixes.
  105. # 1.2  8/94  -  'retrieveOutput' and 'autoSwitch' flags added.
  106. #                'openInMacperl' added.
  107. #                MacPerl output window now closed before new scripts are sent.
  108. #                Filters now abort if there are compilation errors, and
  109. #                MacPerl diagnostic output retrieved and displayed in Alpha.
  110. # 1.1  8/94  -  'quitMacperl' added.
  111. #               perl-mode file-marking updated for Alpha 5.90
  112. #               Simplified installation via 'loadMacperl'(Pete Keleher). 
  113. # 1.0  7/94  -  perl-mode setup updated for Alpha 5.85:
  114. #                    keyword colorization supported
  115. #                    custom file-marking added
  116. #               #! lines in filter scripts now handled correctly 
  117. #               Workarounds installed for AppleEvent bug in MacPerl 4.1.3
  118. # 0.9  3/94  -  perl-mode stuff added, and
  119. #               highlighted 'Perl commands' file (man page) prepared
  120. #               minor bug fixes, too
  121. # 0.8  3/94  -  flags are now check-marked
  122. # 0.7  3/94  -  nested Text Filters folder now supported
  123. #               menu format modified somewhat
  124. # 0.6  3/94  -  'applyToBuffer' flag added
  125. #               scripts in Alpha buffers can now be used as filters 
  126. # 0.5  2/94  -  'filters', 'open special' submenu added
  127. #               'overwrite' flag added
  128. # 0.2  1/94  -  menu support added (Martijn Koster <m.koster@nexor.co.uk>)
  129. #               'execute selection', 'execute buffer' commands added
  130. # 0.1  9/93  -  text filter functionality created
  131. #                  
  132. ##############################################################################
  133. #
  134. proc dummyPerl {} {
  135. }
  136.  
  137. #############################################################################
  138. #  Default settings for the Perl menu flags  
  139. #
  140. set perlDefault(perlUseDebug) 0
  141. set perlDefault(perlGetOutput) 1
  142. set perlDefault(perlAutoSwitch) 1
  143. set perlDefault(perlOverwrite) 0
  144. set perlDefault(perlUsebuffer) 1
  145. set perlDefault(perlPromptArgs) 0
  146. set perlDefault(perlRecycleOutput) 0
  147. set perlDefault(perlPrevScript) {*startup*}
  148. set perlDefault(perlCmdlineArgs) {}
  149. set perlDefault(perlVersion) {4}
  150.  
  151. if {![info exists perlFilterPath]} {
  152.     set perlFilterPath "$HOME:Tcl:UserCode:Text Filters:"
  153. }
  154.  
  155. foreach var [array names perlDefault] {
  156.     if (![info exists PerlmodeVars($var)]) { 
  157.         set $var $perlDefault($var) 
  158.     } else {
  159.         set $var $PerlmodeVars($var) 
  160.     }
  161. }
  162. unset perlDefault
  163.  
  164. ##############################################################################
  165. # Make duplicate copies of these variables as modeVars, taking responsibility
  166. # for keeping the two sets consistent (argh!)
  167. #
  168. # (Maybe it's OK now to let them _just_ be modeVars, and not also ordinary
  169. # variables?)
  170. #
  171.  
  172. newModeVar Perl perlUseDebug $perlUseDebug 1
  173. newModeVar Perl perlGetOutput $perlGetOutput 1
  174. newModeVar Perl perlAutoSwitch $perlAutoSwitch 1
  175. newModeVar Perl perlOverwrite $perlOverwrite 1
  176. newModeVar Perl perlUsebuffer $perlUsebuffer 1
  177. newModeVar Perl perlPromptArgs $perlPromptArgs 1
  178. newModeVar Perl perlRecycleOutput $perlRecycleOutput 1
  179.  
  180. newModeVar Perl perlLastFilter $perlPrevScript 0
  181. newModeVar Perl perlCmdlineArgs $perlCmdlineArgs 0
  182.  
  183. ##############################################################################
  184. # Other Perl-mode variable definitions
  185. #
  186. newModeVar Perl elecRBrace        {0} 1
  187. newModeVar Perl elecLBrace        {1} 1
  188. newModeVar Perl electricSemi    {0} 1
  189. newModeVar Perl electricTab        {1} 1
  190. newModeVar Perl electricReturn    {1} 1
  191. newModeVar Perl wordBreak        {(\$)?\w+} 0
  192. newModeVar Perl prefixString    {# } 0
  193. newModeVar Perl wordWrap        {0} 1
  194. newModeVar Perl funcExpr        {^sub *([+-a-zA-Z0-9]+)} 0
  195. newModeVar Perl wordBreakPreface        {[^a-zA-Z0-9_\$]} 0
  196. newModeVar Perl autoMark    1    1
  197. newModeVar Perl stringColor    green    0
  198.  
  199. newModeVar Perl perlVersion $perlVersion 0
  200.  
  201.  
  202. ##############################################################################
  203. # Miscellaneous definitions
  204. #
  205. set perlErrorWindow {* Perl Error Messages *}
  206. set perlOutputWindow {* Perl Output *}
  207. set interpPat {(#![     !-~]*)}
  208.  
  209. set perlFilterMenu "textFilters"
  210.  
  211. set modeCode ":Tcl:Modes:perl${perlVersion}.tcl"
  212. if {[catch {source $HOME$modeCode}]} {
  213.     alertnote "Couldn't load the Perl-mode colorization file \"$modeCode\".  Contact the maintainer."
  214. }
  215.  
  216. #############################################################################
  217. #  Return paths to standard files, based on the path to MacPerl:
  218. #
  219. proc macperlFolder {} {
  220.    set name [nameFromAppl McPL]
  221.    regexp {(.*):([^:]*)} $name pathname dirname filename
  222.    return ${dirname}:
  223. }
  224.  
  225. proc stdinPath {} {
  226.    return [macperlFolder]STDIN
  227. }
  228.  
  229. proc scriptPath {} {
  230.    return [macperlFolder]SCRIPT
  231. }
  232.  
  233. #############################################################################
  234. # Define the dummy proc that will be called when the perl menu
  235. # is first inserted into the menubar
  236. #
  237. proc perlMenu {} {}
  238.  
  239. #############################################################################
  240. #  Build the perl menu
  241. #            
  242. set perlMenu "•132"
  243. set perlOptsMenu "generalOptions"
  244. set filtOptsMenu "filterOptions"
  245.  
  246. menu -n $perlMenu [ concat {
  247.         "/'<Umacperl"
  248.         {menu -m -n "tellMacperl..." -p perlTellProc {
  249.            "/O<UOpen This File"
  250.            "Save As Droplet"
  251.            "Save As Runtime"
  252.            "Save As CGI"
  253.             "(-"
  254.            "Get Output Window"
  255.            "Close Output Window"
  256.            "Quit"
  257.            }
  258.         } 
  259.         {menu -m -n "Quick Save As..." -p perlSaveProc {
  260.            "Droplet"
  261.            "Runtime"
  262.            "CGI"
  263.            }
  264.         } 
  265.         {menu -m -n help -p perlHelpProc {
  266.             "MacPerl Mode"
  267.             "Mac Specifics"
  268.             "Perl4 Manual"
  269.             "Perl5 Manual"
  270.         }}
  271.         "(-"
  272.         "runTheSelection"
  273.         "/R<UrunTheBuffer"
  274.         "/R<B<OsaveAndRun"
  275.         "runAFile"
  276.         "(-"
  277.     } [list [list menu -n $perlFilterMenu {}]] {
  278.        "selectBufferAsFilter"
  279.        "selectFileAsFilter"
  280.        "/F<UrepeatLastFilter"
  281.        "(-" 
  282.     } [list [list menu -n $perlOptsMenu {}]] {
  283.     } [list [list menu -n $filtOptsMenu {}]] {
  284.     } ]
  285.  
  286. enableMenuItem $perlMenu perlDebugWindow 0
  287. enableMenuItem "tellMacperl..." "Save As CGI" 1
  288.  
  289. if {$perlPrevScript == {} || $perlPrevScript == {*startup*}} {
  290.     enableMenuItem $perlMenu repeatLastFilter 0
  291. }
  292.  
  293. # General Perl-menu options menu
  294. #
  295. menu -n $perlOptsMenu {
  296.     "retrieveOutput"
  297.     "autoSwitch"
  298.     "promptForArgs"
  299.     "useDebugger"
  300.     }    
  301. markMenuItem $perlOptsMenu useDebugger $perlUseDebug
  302. markMenuItem $perlOptsMenu retrieveOutput $perlGetOutput
  303. markMenuItem $perlOptsMenu autoSwitch $perlAutoSwitch
  304. markMenuItem $perlOptsMenu promptForArgs $perlPromptArgs
  305.  
  306. # Text Filter options menu
  307. #
  308. menu -n $filtOptsMenu {
  309.     "applyToBuffer"
  310.     "overwriteSelection"
  311.     "(-"
  312.     "textFiltersFolder"
  313.     "rebuildFilterMenu"
  314.     }    
  315. markMenuItem $filtOptsMenu overwriteSelection $perlOverwrite
  316. markMenuItem $filtOptsMenu applyToBuffer $perlUsebuffer
  317.  
  318.  
  319. #############################################################################
  320. #  Build a submenu of "preattached" Perl filters using the names of the 
  321. #  scripts in the Text Filters directory.  Called whenever Text Filters
  322. # folder is reassigned.
  323. #
  324. proc rebuildFilterMenu {{args}} {
  325.     global perlFilters perlFilterMenu perlFilterPath
  326.     global $perlFilterMenu
  327.     
  328.     eval [buildSubMenu [list $perlFilterPath] $perlFilterMenu textFiltersProc perlFilters]
  329. }
  330.  
  331. rebuildFilterMenu
  332.  
  333. #############################################################################
  334. # Use variable tracing to keep global vars and modeVars consistent.
  335. #
  336. trace variable PerlmodeVars(perlUseDebug) w shadowPerl
  337. trace variable PerlmodeVars(perlOverwrite) w shadowPerl
  338. trace variable PerlmodeVars(perlUsebuffer) w shadowPerl
  339. trace variable PerlmodeVars(perlGetOutput) w shadowPerl
  340. trace variable PerlmodeVars(perlAutoSwitch) w shadowPerl
  341. trace variable PerlmodeVars(perlPromptArgs) w shadowPerl
  342. trace variable PerlmodeVars(perlLastFilter) w shadowPerl
  343. trace variable PerlmodeVars(perlCmdlineArgs) w shadowPerl
  344. trace variable PerlmodeVars(perlRecycleOutput) w shadowPerl
  345. trace variable PerlmodeVars(perlVersion) w shadowPerl
  346.  
  347. # perlFilterPath is now just a regular variable, set from the App Paths submenu
  348. trace variable perlFilterPath w rebuildFilterMenu
  349.  
  350. # ShadowPerl sets the global vars when the mode vars are modified and
  351. # keeps the menu checkmarked correctly.
  352. #
  353. proc shadowPerl {name1 name2 op} {
  354.     global HOME perlMenu perlOptsMenu filtOptsMenu
  355.     global perlOverwrite perlUsebuffer perlGetOutput perlAutoSwitch
  356.     global perlPromptArgs perlPrevScript perlCmdlineArgs perlUseDebug
  357.     global PerlmodeVars
  358.     if {$name1 == "PerlmodeVars" && $op == "w"} {
  359.         switch $name2 {
  360.             "perlUseDebug"    {
  361.                 set perlUseDebug $PerlmodeVars(perlUseDebug)
  362.                 markMenuItem $perlOptsMenu useDebugger $perlUseDebug
  363.              }
  364.             "perlOverwrite"    {
  365.                 set perlOverwrite $PerlmodeVars(perlOverwrite)
  366.                 markMenuItem $filtOptsMenu overwriteSelection $perlOverwrite
  367.              }
  368.             "perlUsebuffer"    {
  369.                 set perlUsebuffer $PerlmodeVars(perlUsebuffer)
  370.                 markMenuItem $filtOptsMenu applyToBuffer $perlUsebuffer
  371.              }
  372.             "perlGetOutput"    {
  373.                 set perlGetOutput $PerlmodeVars(perlGetOutput)
  374.                 markMenuItem $perlOptsMenu retrieveOutput $perlGetOutput 
  375.             }
  376.             "perlAutoSwitch" {    
  377.                 set perlAutoSwitch $PerlmodeVars(perlAutoSwitch)
  378.                 markMenuItem $perlOptsMenu autoSwitch $perlAutoSwitch 
  379.             }
  380.             "perlPromptArgs" {    
  381.                 set perlPromptArgs $PerlmodeVars(perlPromptArgs)
  382.                 markMenuItem $perlOptsMenu promptForArgs $perlPromptArgs 
  383.             }
  384.             "perlCmdlineArgs" {    
  385.                 set perlCmdlineArgs $PerlmodeVars(perlCmdlineArgs)
  386.             }
  387.             "perlRecycleOutput" {    
  388.                 set perlRecycleOutput $PerlmodeVars(perlRecycleOutput)
  389.             }
  390.             "perlVersion" {    
  391.                 set perlVersion $PerlmodeVars(perlVersion)
  392.                 set modeCode ":Tcl:Modes:perl${perlVersion}.tcl"
  393.                 if {[catch {source $HOME$modeCode}]} {
  394.                     alertnote "Couldn't load the Perl-mode colorization file \"$modeCode\".  Contact the maintainer."
  395.                 }
  396.             }
  397.             "perlLastFilter" {    
  398.                 # Don't allow perlPrevScript to be changed from the flags menu
  399.                 if {$perlPrevScript == "*startup*"} {
  400.                     set perlPrevScript $PerlmodeVars(perlLastFilter)
  401.                     enableMenuItem $perlMenu repeatLastFilter 1
  402.                 } else {
  403.                     set PerlmodeVars(perlLastFilter) $perlPrevScript 
  404.                 }
  405.             }
  406.             default {
  407.                 return
  408.             }
  409.         }
  410.     }
  411. }
  412.  
  413. #############################################################################
  414. # Menu commands
  415. #############################################################################
  416.  
  417. ############################################################################
  418. # Toggle the perl menu flags
  419. #
  420. proc retrieveOutput {} {
  421.     global perlMenu PerlmodeVars perlGetOutput modifiedModeVars
  422.     lappend modifiedModeVars [list perlGetOutput PerlmodeVars]
  423.     if {$perlGetOutput} then {
  424.         set PerlmodeVars(perlGetOutput) 0
  425.     } else {
  426.         set PerlmodeVars(perlGetOutput) 1
  427.     }
  428. }
  429.  
  430. proc useDebugger {} {
  431.     global perlMenu PerlmodeVars perlUseDebug modifiedModeVars
  432.     lappend modifiedModeVars [list  perlUseDebug PerlmodeVars]
  433.     if {$perlUseDebug} then {
  434.         set PerlmodeVars(perlUseDebug) 0
  435.     } else {
  436.         set PerlmodeVars(perlUseDebug) 1
  437.     }
  438. }
  439.  
  440. proc autoSwitch {} {
  441.     global perlMenu PerlmodeVars perlAutoSwitch modifiedModeVars
  442.     lappend modifiedModeVars [list  perlAutoSwitch PerlmodeVars]
  443.     if {$perlAutoSwitch} then {
  444.         set PerlmodeVars(perlAutoSwitch) 0
  445.     } else {
  446.         set PerlmodeVars(perlAutoSwitch) 1
  447.     }
  448. }
  449.  
  450. proc overwriteSelection {} {
  451.     global perlMenu perlOverwrite PerlmodeVars modifiedModeVars
  452.     lappend modifiedModeVars [list  perlOverwrite PerlmodeVars]
  453.     if {$perlOverwrite} then {
  454.         set PerlmodeVars(perlOverwrite) 0
  455.     } else {
  456.         set PerlmodeVars(perlOverwrite) 1
  457.     }
  458. }
  459.  
  460. proc applyToBuffer {} {
  461.     global perlMenu perlUsebuffer PerlmodeVars modifiedModeVars
  462.     lappend modifiedModeVars [list  perlUsebuffer PerlmodeVars]
  463.     if {$perlUsebuffer} then {
  464.            set PerlmodeVars(perlUsebuffer) 0
  465.     } else {
  466.            set PerlmodeVars(perlUsebuffer) 1
  467.     }
  468. }
  469.  
  470. proc promptForArgs {} {
  471.     global perlMenu perlPromptArgs PerlmodeVars modifiedModeVars
  472.     lappend modifiedModeVars [list perlPromptArgs PerlmodeVars]
  473.     if {$perlPromptArgs} then {
  474.            set PerlmodeVars(perlPromptArgs) 0
  475.     } else {
  476.            set PerlmodeVars(perlPromptArgs) 1
  477.     }
  478. }
  479.  
  480. proc textFiltersFolder {} {
  481.     global perlMenu perlFilterPath PerlmodeVars modifiedModeVars pathComments
  482.     
  483.     pathProc {} $pathComments(perlFilterPath)
  484. }
  485.  
  486. #############################################################################
  487. # Switch to MacPerl:
  488. # 
  489. proc macperl {} {
  490.     launchForeAppl McPL
  491. }
  492.  
  493. #############################################################################
  494. # Interact with MacPerl in some other way besides executing a script
  495. #
  496. #DTH: note addition of two lines for auto-save
  497. proc perlTellProc {menu name} {
  498.     switch -exact $name {
  499.     "Open This File"        { openInMacperl }
  500.     
  501.     "Save As Droplet"        { saveThruMacperl "droplet" }
  502.     
  503.     "Save As Runtime"        { saveThruMacperl "runtime" }
  504.     
  505.     "Save As CGI"            { saveThruMacperl "cgi" }
  506.     
  507.     "Get Output Window"        { openPerlOutput }
  508.     
  509.     "Close Output Window"    { sendCloseWinName MacPerl $perlName ;
  510.                               sendCloseWinName MacPerl "Perl Debug" }
  511.                             
  512.     "Quit"                    { quitMacperl }
  513.     }
  514. }
  515.  
  516. proc perlSaveProc {menu name} {
  517.     switch -exact $name {
  518.     "Droplet"    { saveThruMacperl "auto-droplet" }
  519.     
  520.     "Runtime"    { saveThruMacperl "auto-runtime" }
  521.  
  522.     "CGI"        { saveThruMacperl "auto-cgi" }
  523.     }
  524. }
  525.  
  526. #############################################################################
  527. # Open the current file under MacPerl.  This used to useful for saving files 
  528. # as droplets or runtime scripts.  Maybe it's still useful for something...?
  529. #
  530. proc openInMacperl {} {
  531.     if {[winDirty]} {
  532.         case [askyesno -c "Save '[lindex [winNames] 0]'?"] in {
  533.             "yes" {save}
  534.             "no" {}
  535.             "cancel" {return}
  536.         }
  537.     }
  538.     set name [launchForeAppl McPL]
  539.     sendOpenEvent -n [file tail $name] [car [winNames -f]]
  540. }
  541.  
  542. #############################################################################
  543. # Save the script in the current window as a MacPerl droplet or 
  544. # runtime script.  
  545. #
  546. proc saveThruMacperl {type} {
  547.     global ALPHA
  548.  
  549.     set name [file tail [launchBackAppl McPL]]
  550.     getWinInfo arr
  551.     if {$arr(dirty) == 1} {
  552.         case [askyesno -c "Save '[lindex [winNames] 0]' source file also?"] in {
  553.             "yes" {save}
  554.             "no" {}
  555.             "cancel" {return}
  556.         }
  557.     }
  558.     #DTH note the following "if" block which replaced what is in the new "else" block
  559.     set myName [lindex [winNames -f] 0]
  560.     if {$type == "auto-droplet" || $type == "auto-runtime"} {
  561.         if {[file extension $myName] == ".pl"} {
  562.             set destfile [AEFilename [file rootname $myName]]
  563.         } else {
  564.             set destfile [AEFilename [file rootname $myName]]
  565.         }
  566.     } elseif {$type == "auto-cgi"} {
  567.         set destfile [AEFilename "[file rootname $myName].cgi"]
  568.     } else {
  569.         set destfile [AEFilename [putfile {Save droplet as} [lindex [winNames] 0]]]
  570.     }
  571.  
  572.     set script [curlyq [getText 0 [maxPos]]]
  573.     #DTH note addition of "auto-xxx" in two lines below
  574.     if {$type == "droplet" || $type == "auto-droplet"} {
  575.         set saveType "SCPT"
  576.     } elseif {$type == "runtime" || $type == "auto-runtime"} {
  577.         set saveType "MrP7"
  578.     } elseif {$type == "cgi" || $type == "auto-cgi"} {
  579.         set saveType "'WWWΩ'"
  580.     } elseif {$type == "text"} {
  581.         set saveType "TEXT"
  582.     }
  583.     
  584.     set err [catch {eval "AEBuild -t 36000 -r \"$name\"" core save {----} [list $script] {dest:} [list $destfile] {fltp:} $saveType } reply ]
  585.     if {$err} { message "AEBuild error code $err in saveThruMacperl" }
  586.     
  587. # The following lines could be used to tell MacPerl to take the script file 
  588. # from an existing disk file and then re-save it in the desired form.
  589. #
  590. #    set srcfile "\[ [AEFilename [car [winNames -f]]] \]"
  591. #    set reply [eval "AEBuild -t 36000 -r \"$name\"" core save {----} [list $srcfile] {dest:} [list $destfile] {fltp:} $saveType ]
  592. #
  593. }
  594.  
  595. #############################################################################
  596. # Quit a running MacPerl app:
  597. # 
  598. proc quitMacperl {} {
  599.     foreach proc [processes] {
  600.         set sig [lindex $proc 1]
  601.         if {$sig == "McPL"} {
  602.             sendQuitEvent [lindex $proc 0]
  603.             # switchTo is necessary to keep MacPerl from blinking
  604.             switchTo [lindex $proc 0]    
  605.         }
  606.     }
  607. }
  608.  
  609. #############################################################################
  610. # Run the selection as a MacPerl script:
  611. # (No special arrangements are made to provide input or capture the output)
  612. # 
  613. proc runTheSelection {} {
  614.     global scriptFile scriptStart
  615.     set scriptFile [car [winNames -f]]
  616.     set scriptStart [lindex [posToRowCol [getPos]] 0]
  617.     perlExecuteScript [getSelect]
  618. }
  619.  
  620. proc runTheBuffer {} {
  621.     global scriptFile scriptStart
  622.     set scriptFile [car [winNames -f]]
  623.     set scriptStart 1
  624.     perlExecuteScript [getText 0 [maxPos]]
  625. }
  626.  
  627. proc runAFile {} {
  628.     global scriptFile scriptStart
  629.     if {! [catch {getfile "Select a Perl script"} path]} {
  630.         set scriptFile $path
  631.         set scriptStart 1
  632.         perlExecuteFile $path
  633.     }
  634. }
  635.  
  636. proc saveAndRun {} {
  637.     global scriptFile scriptStart
  638.     save
  639.     set path [car [winNames -f]]   
  640.     set scriptFile $path
  641.     set scriptStart 1
  642.     perlExecuteFile $path
  643. }
  644.  
  645. #############################################################################
  646. # Run a preattached Perl text-filter script selected from the menu:
  647. #
  648. proc textFiltersProc {menu name} {
  649.     global perlFilters scriptFile scriptStart
  650.     
  651.     perlFileAsFilter $perlFilters($menu:$name)
  652. }
  653.  
  654. #############################################################################
  655. # Reuse the previous (buffer or file) filter:
  656. #
  657. proc repeatLastFilter {} {
  658.     global scriptFile scriptStart perlPrevScript perlMenu PerlmodeVars
  659.     if {$perlPrevScript != {}} {
  660.         set stype [lindex $perlPrevScript 0]
  661.         set name [lindex $perlPrevScript 1]
  662.         if {$stype == "file"} {
  663.             perlFileAsFilter $name
  664.         } elseif {$stype == "buffer"} {
  665.             perlBufferAsFilter $name
  666.         } else {
  667.             message "Bogus filter name : \"$perlPrevScript\""
  668.             set perlPrevScript {}
  669.             set PerlmodeVars(perlLastFilter) $perlPrevScript 
  670.             enableMenuItem $perlMenu repeatLastFilter 0
  671.         }
  672.     }
  673. }
  674.  
  675. #############################################################################
  676. # Ask for a file containing a Perl script to use as a filter:
  677. #
  678. proc selectFileAsFilter {} {
  679.     global scriptFile scriptStart perlPrevScript
  680.     if {! [catch {getfile "Select a MacPerl script"} path]} {
  681.         perlFileAsFilter $path
  682.     }
  683. }
  684.  
  685. #############################################################################
  686. # Ask for an Alpha buffer containing a Perl script to use as a filter:
  687. #
  688. proc selectBufferAsFilter {} {
  689.     global scriptFile scriptStart perlPrevScript
  690.     
  691.     set windows [winNames]
  692.     set current [lindex $windows 0]
  693.     if {[llength $windows] > 1} {
  694.         set name [listpick [lsort $windows]]
  695.         if {[string length $name]} {
  696.             # get the full name of the chosen window
  697.             set wname [lindex [winNames -f] [lsearch -exact $windows $name]]
  698.             perlBufferAsFilter $wname
  699.            }
  700.     }
  701. }
  702.  
  703. #############################################################################
  704. # Open a file from the MacPerl application folder - used by "Open Special"
  705. #
  706. proc perlOpenFile {menu name} {
  707.     set filename [macperlFolder]$name
  708.     if {[file exists $filename]} {
  709.         edit $filename
  710.     } else {
  711.         alertnote "That file doesn't exist yet"
  712.     }
  713. }
  714.  
  715. #############################################################################
  716. # Support procs
  717. #############################################################################
  718.  
  719. #############################################################################
  720. # Prompt the user to enter a string containing command-line args.
  721. #
  722. proc getCmdlineArgs {} {
  723.     global PerlmodeVars
  724.     set oldargs $PerlmodeVars(perlCmdlineArgs)
  725.     if {![catch {prompt "Command-line arguments (if any):" $oldargs} args]} {
  726.         set PerlmodeVars(perlCmdlineArgs) $args
  727.     } else {
  728.         error "getCmdlineArgs: User cancelled"
  729.     }
  730.     return $args
  731. }
  732.  
  733. #############################################################################
  734. # Tell MacPerl to run a script file:
  735. #
  736. proc perlExecuteFile {path {args {}} {flags {}}} {
  737.     global ALPHA
  738.     global perlGetOutput perlAutoSwitch perlPromptArgs perlUseDebug
  739.     global scriptFile scriptStart filterHeadLen perlName
  740.     
  741.     if {[string length $path]} {
  742.         set perlName [file tail [launchBackAppl McPL]]
  743.         if {[string length $perlName]} {
  744.                 
  745.             set ok [regexp {(.*):([^:]*)} $path pathname dirname filename]
  746.             if {!$ok} {    set name $wname    }
  747.  
  748.             if {$path != [scriptPath]} {    
  749.                 set filterHeadLen 0    
  750.             }
  751.             
  752.             if {$perlUseDebug} {
  753.                 append flags "debug"
  754.             }
  755.             if {$perlPromptArgs} { 
  756.                 append args " [getCmdlineArgs]"
  757.             }
  758.             
  759.             sendCloseWinName $perlName $perlName
  760.             sendCloseWinName $perlName "Perl Debug"
  761.             if {$perlAutoSwitch || $perlUseDebug} then {
  762.                 switchTo $perlName
  763.             } else {
  764.                 message "Running file \"$filename\" as Perl script"
  765.                 watchCursor
  766.             }
  767.             
  768.             perlDoScript $perlName $path $args {} $flags
  769.             
  770. # (not sure which choice is better...)
  771. #            if {!$perlAutoSwitch} then {switchTo $ALPHA}
  772.             switchTo $ALPHA
  773. #
  774.             if {![getMacPerlError]} {
  775.                 if {$perlGetOutput} then {openPerlOutput}
  776.             }
  777.         } else {
  778.             alertnote "Couldn't run MacPerl"
  779.         }
  780.     } else {
  781.         alertnote "No file specified to execute"
  782.     }
  783. }
  784.  
  785. #############################################################################
  786. # Run a MacPerl script, passed explicitly as a string:
  787. #
  788. # If no "#!/bin/perl" line already exists, one is preprended to the script
  789. # by wrapSelectScript, which also sets $filterHeadLen for use by 
  790. # getMacPerlError.
  791. # 
  792. proc perlExecuteScript {script {args ""} {flags {}} } {
  793.     global perlGetOutput perlAutoSwitch perlPromptArgs perlName
  794.     global scriptFile scriptStart filterHeadLen perlUseDebug ALPHA
  795.     
  796.     if {$script != ""} {
  797.         set script [wrapSelectScript $script]
  798.         
  799.         if {![regexp {(.*):([^:]*)} $scriptFile pathname dirname filename]} {
  800.             set filename $scriptFile 
  801.         }
  802.  
  803.         set perlName [file tail [launchBackAppl McPL]]
  804.         if {[string length $perlName]} {
  805.         
  806.             if {$perlUseDebug} {
  807.                 append flags "debug"
  808.             }
  809.             if {$perlPromptArgs} { 
  810.                 append args " [getCmdlineArgs]"
  811.             }
  812.             
  813.             sendCloseWinName $perlName $perlName
  814.             sendCloseWinName $perlName "Perl Debug"
  815.             if {$perlAutoSwitch || $perlUseDebug} then {
  816.                 switchTo $perlName
  817.             } else {
  818.                 message "Running buffer \"$filename\" as Perl script"
  819.                 watchCursor
  820.             }
  821.             
  822.             perlDoScript $perlName $script $args {} $flags
  823.             
  824.             switchTo $ALPHA
  825.  
  826.             if {![getMacPerlError]} {
  827.                 if {$perlGetOutput} then {openPerlOutput}
  828.             }
  829.         }
  830.         
  831.     } else {
  832.             alertnote "Can't run an empty script"
  833.     }
  834. }
  835.  
  836. #############################################################################
  837. # Prepare the contents of a disk file for use as a text-filter script. 
  838. # (calls perlTextFilter to actually run the script)
  839. # 
  840. proc perlFileAsFilter {path} {
  841.     global scriptFile scriptStart perlPrevScript perlMenu PerlmodeVars
  842.     
  843.     regexp {(.*):([^:]*)} $path pathname dirname name
  844.     
  845.     if {![catch {readFile $path} coreScript]} {
  846.         set scriptFile $path
  847.         set scriptStart 1
  848.         set script [wrapFilterScript $coreScript]
  849.         set perlPrevScript [list "file" $path]
  850.         set PerlmodeVars(perlLastFilter) $perlPrevScript 
  851.         enableMenuItem $perlMenu repeatLastFilter 1
  852.         message "Running file \"$name\" as text filter ..."
  853.         
  854.         perlTextFilter $script
  855.     } else {
  856.         set perlPrevScript {}
  857.         set PerlmodeVars(perlLastFilter) $perlPrevScript 
  858.         enableMenuItem $perlMenu repeatLastFilter 0
  859.         
  860.         alertnote "Couldn't read the script file : $path"
  861.         return
  862.     }
  863. }
  864.  
  865. #############################################################################
  866. # Prepare the contents of a text window for use as a text-filter script. 
  867. # (calls perlTextFilter to actually run the script)
  868. # 
  869. proc perlBufferAsFilter {wname} {
  870.     global scriptFile scriptStart perlPrevScript perlMenu PerlmodeVars perlName
  871.  
  872.     set ok [regexp {(.*):([^:]*)} $wname pathname dirname name]
  873.     if {!$ok} {    set name $wname    }
  874.     
  875.     if {[lsearch [winNames -f] $wname] >= 0} {
  876.         set coreScript [getText -w $wname 0 [maxPos -w $wname]]
  877.         
  878.         # Does it have any text in it?
  879.         if {[string length $coreScript]} {
  880.             set scriptFile $wname
  881.             set scriptStart 1
  882.             set script [wrapFilterScript $coreScript]
  883.             set perlPrevScript [list "buffer" $wname]
  884.             set PerlmodeVars(perlLastFilter) $perlPrevScript 
  885.             enableMenuItem $perlMenu repeatLastFilter 1
  886.             message "Running buffer \"$name\" as text filter ..."
  887.             
  888.             perlTextFilter $script
  889.         }
  890.     } else {
  891.         set perlPrevScript {}
  892.         set PerlmodeVars(perlLastFilter) $perlPrevScript 
  893.         enableMenuItem $perlMenu repeatLastFilter 0
  894.  
  895.         alertnote "Couldn't find buffer : $name"
  896.     }
  897. }
  898.  
  899. #############################################################################
  900. # Run a Perl script as a command-line text filter, arranging for a text
  901. # buffer to be attached as standard input.  The calling routine should already
  902. # have processed the script with wrapFilterScript.  This routine actually
  903. # send the script and takes care of writing the input and reading the output 
  904. # files.
  905. # 
  906. proc perlTextFilter {script {args {}} {flags {}}} {
  907.     global perlOverwrite perlUsebuffer perlPromptArgs
  908.     global filterHeadLen scriptFile scriptStart perlUseDebug ALPHA
  909.     global perlOutputWindow perlRecycleOutput perlName
  910.  
  911.     set perlName [file tail [launchBackAppl McPL]]
  912.     if {![string length $perlName]} {
  913.         alertnote "Couldn't run MacPerl"
  914.         error "Couldn't run MacPerl"
  915.     }
  916.     writeStdin
  917.  
  918.     if {$perlUseDebug} {
  919.         append flags "debug"
  920.     }
  921.     if {$perlPromptArgs} { 
  922.         append args " [getCmdlineArgs]"
  923.     }
  924.     
  925.     sendCloseWinName $perlName $perlName
  926.     sendCloseWinName $perlName "Perl Debug"
  927.     
  928.     if {$perlUseDebug} then {
  929.         switchTo $perlName
  930.         perlDoScript $perlName [scriptPath] $args [list [stdinPath]] $flags
  931.         set err [getMacPerlError]
  932.  
  933.     } else {
  934.         watchCursor
  935.         set reply [perlDoScriptBatch $perlName [scriptPath] $args [list [stdinPath]]]
  936.         set err [getBatchError $reply]
  937.     }
  938.     
  939.     switchTo $ALPHA
  940.     
  941.     if {$err == 0} {
  942.         if {$perlUseDebug} {
  943.             set outp [sendGetText $perlName $perlName]
  944.         } else {
  945. #            set outp [parseReplyOutp $reply]
  946.             set outp [parseReplyResult $reply]
  947.         }
  948.         pasteFilterResult $outp
  949.     }
  950. }
  951.  
  952.  
  953. #############################################################################
  954. # Check the MacPerl output window for error messages.
  955. #
  956. proc getMacPerlError {} {
  957.     
  958.     set diag [getPerlDiag 40]
  959.     set errf [parseDiagErrf $diag]
  960.     set srcs [parseDiagSrcs $diag]
  961.     set mesg [parseDiagMesg $diag]
  962.  
  963.     if {[string length $errf]} {
  964.         showPerlDiag $diag [string length $diag] $mesg $errf $srcs
  965.         gotoPerlError $errf $srcs $mesg
  966.         return 1
  967.         
  968.     } else {
  969.         return 0
  970.     }
  971. }
  972.  
  973. #############################################################################
  974. # Check the MacPerl batch reply for error messages.
  975. #
  976. proc getBatchError {reply} {
  977.     global perlErrorWindow
  978.     
  979.     set fatalError 0
  980.     set diag [parseReplyDiag $reply]
  981.     set errf [parseDiagErrf  $diag ]
  982.     set srcs [parseReplySrcs $reply]
  983.     set mesg [parseDiagMesg  $diag ]
  984.     set errn [parseReplyErrn $reply]
  985.  
  986.     if {$errn} {        
  987.         showPerlDiag $diag $errn $mesg $errf $srcs
  988.         gotoPerlError $errf $srcs $mesg
  989.         set fatalError 1
  990.         
  991.     } elseif {[string length $diag] > 0} {
  992.         showPerlDiag $diag $errn $mesg $errf $srcs
  993.     }
  994.     
  995.     return $fatalError
  996. }
  997.  
  998. #############################################################################
  999. # Display the Perl diagnostic output in its own window.
  1000. #
  1001. proc showPerlDiag {diag {errn 1} {mesg {}} {errf {}} {srcs {}}} {
  1002.         global perlErrorWindow    
  1003.         
  1004.         set currWin [lindex [winNames] 0]
  1005.         if {[lsearch [winNames] $perlErrorWindow] >= 0} {
  1006.             bringToFront $perlErrorWindow
  1007.             setWinInfo read-only 0
  1008.             deleteText 0 [maxPos] 
  1009.             insertText $diag
  1010.         } else {
  1011.             new -n $perlErrorWindow 
  1012.              insertText $diag
  1013.         }
  1014.         
  1015.         goto 0
  1016.         catch {shrinkWindow 2}
  1017.         setWinInfo dirty 0
  1018.         setWinInfo read-only 1
  1019.         bringToFront $currWin
  1020. }
  1021.  
  1022. #############################################################################
  1023. # Bring up a window containing the bug-ridden Perl code and highlight the
  1024. # line at which the error was found.
  1025. #
  1026. proc gotoPerlError {errf srcs {mesg {}}} {
  1027.     global scriptFile scriptStart filterHeadLen
  1028.  
  1029.     if {$errf == [scriptPath] || $errf == "<AppleEvent>"} {
  1030.         set errf $scriptFile
  1031.         # Convert it to the line number in the original file
  1032.         set srcs [expr $srcs + $scriptStart - $filterHeadLen - 1]
  1033.     }
  1034.     # ... and leave an informative error message
  1035.     #
  1036.     if {[string length $mesg]} {
  1037.         set mesg "$mesg at Line $srcs"            
  1038.     } else {
  1039.         set mesg "MacPerl flagged an error at Line $srcs"    
  1040.     }
  1041.     
  1042.     # Bring up the script file and highlight the flagged line
  1043.     #
  1044.     catch {gotoFileLine $errf $srcs $mesg} fname    
  1045. }
  1046.  
  1047. #############################################################################
  1048. # Read the first block of lines (up to a maximum number) from the MacPerl
  1049. # output window.
  1050. #
  1051. proc getPerlDiag {maxlines} {
  1052.     global perlName
  1053.     set pat0 {^[ \t]*$}
  1054.  
  1055.     set lines {}    
  1056.  
  1057.     # read first $maxlines of output to the MacPerl window
  1058.     # (faster, but assumes error message won't appear at 
  1059.     # the end of a lot of output).
  1060.     #
  1061.     set nlines [sendCountLines $perlName MacPerl]
  1062.     set nlines [expr ($nlines > $maxlines)?$maxlines:$nlines]
  1063.     if {$nlines > 0} {
  1064.         set output [sendGetText $perlName $perlName 1 $nlines]
  1065.         
  1066.         foreach line [split $output "\r"] {
  1067.             if  {[regexp $pat0 $line mtch]} {
  1068.                 break
  1069.             } else {
  1070.                 append lines "$line\n"
  1071.             }
  1072.         }
  1073.     }
  1074.     return $lines
  1075. }
  1076.  
  1077. #############################################################################
  1078. # Extract various items out of the MacPerl diagnostic output
  1079. #
  1080.  
  1081. # Name of the file in which the error was found
  1082. #
  1083. proc parseDiagErrf {diag}    {
  1084.     if {![regexp {File '([^']+)'; Line} $diag allofit errf]} { 
  1085.         set errf {}
  1086.     }
  1087.     return $errf
  1088. }
  1089.  
  1090. # The line number on which the error was found
  1091. #
  1092. proc parseDiagSrcs {diag}    {
  1093.     if {![regexp {File '[^']+'; Line ([0-9]+)} $diag allofit srcs]} { 
  1094.         set srcs 0 
  1095.     }
  1096.     return $srcs
  1097. }
  1098.  
  1099. # The error message associated with error
  1100. #
  1101. proc parseDiagMesg {diag} {
  1102.     set pat1 {^#(.*)$}
  1103.     set pat2 {File '([^']+)'; Line ([0-9]+)}
  1104.     
  1105.     set errMessage {}
  1106.     set errFound 0
  1107.     
  1108.     foreach line [split $diag "\n"] {
  1109.         if {[regexp $pat2 $line mtch num]} {
  1110.             set errFound 1
  1111.         } elseif {[regexp $pat1 $line mtch err]} {
  1112.             if {$errFound == 0} {
  1113.                 set errMessage $err
  1114.             }
  1115.         }
  1116.     }
  1117.     return $errMessage
  1118. }
  1119.  
  1120. #############################################################################
  1121. # Extract various return parameters out of a MacPerl DoScript reply
  1122. #
  1123.  
  1124. # Result from batch script
  1125. #
  1126. proc parseReplyResult {reply} {
  1127.     if {![regexp {'?\-\-\-\-'?:“([^”]*)”} $reply allofit result]} { 
  1128.         set result {}
  1129.     }
  1130.     return $result
  1131. }
  1132.  
  1133. # Standard output of batch script
  1134. #
  1135. proc parseReplyOutp {reply} {
  1136.     if {![regexp {OUTP:“([^”]*)”} $reply allofit outp]} { 
  1137.         set outp {}
  1138.     }
  1139.     return $outp
  1140. }
  1141.  
  1142. # Diagnostic output of the batch script
  1143. #
  1144. proc parseReplyDiag {reply}    {
  1145.     if {[regexp {diag:“([^”]*)”} $reply allofit diag]}  {
  1146.     } else { 
  1147.         set diag {}
  1148.     }
  1149.     return $diag
  1150. }
  1151.  
  1152. # File alias of the script file in which the error was found
  1153. #
  1154. proc parseReplyErob {reply}    {
  1155.     if {![regexp {erob:alis\(«(.*)»\)} $reply allofit erob]} {
  1156.         set erob {} 
  1157.     }
  1158.     return $erob
  1159. }
  1160.  
  1161. # First line flagged in error
  1162. #
  1163. proc parseReplySrcs {reply}    {
  1164.     if {![regexp {erng:{srcs:([0-9]+)[^\}]*}} $reply allofit srcs]} { 
  1165.         set srcs 0 
  1166.     }
  1167.     return $srcs
  1168. }
  1169.  
  1170. # Last line flagged in error
  1171. #
  1172. proc parseReplySrce {reply}    {
  1173.     if {![regexp {erng:{[^\}]*srce:([0-9]+)}} $reply allofit srce]} { 
  1174.         set srce 0
  1175.     }
  1176.     return $srce
  1177. }
  1178.  
  1179. # Error number
  1180. #
  1181. proc parseReplyErrn {reply}    {
  1182.     if {![regexp {errn:([0-9]+)} $reply allofit errn]} {
  1183.         set errn 0
  1184.     }
  1185.     return $errn
  1186. }
  1187.  
  1188. #############################################################################
  1189. #  Take a Perl script and add commands to take the file STDIN as standard
  1190. #  input and STDOUT as standard output.  This allows scripts written as
  1191. #  Unix command-line filters to be used in the (non-MPW) Mac environment as
  1192. #  text filters.
  1193. #
  1194. #  If there's already a #! line in the script, then the new commands
  1195. #  are added after that line.  If there was no #! line in the first place,
  1196. #  one is added, in case MacPerl is set up to require it (can't hurt...) 
  1197. #
  1198. #  $filterHeadLen counts the number of lines we add to the top of the
  1199. #  original script, so that we can allow for it in interpreting error
  1200. #  messages issued by MacPerl.
  1201. #
  1202. #  *** As of MacPerl 4.1.4, this business is pretty much obsolete ***
  1203. #
  1204. proc wrapFilterScript {coreScript} {
  1205.     global scriptStart filterHeadLen interpPat
  1206.  
  1207.     if {[regexp -indices $interpPat $coreScript allofit cmdln]} {
  1208.         set endPos [lindex $cmdln 1]
  1209.         set filterHead [string range $coreScript 0 [expr $endPos+1]]
  1210.         set coreScript [string range $coreScript [expr $endPos+2] end]
  1211.         set filterHeadLen 0
  1212.         incr scriptStart [expr [llength [split $filterHead "\n\r"]] -2]
  1213.     } else {
  1214.         set filterHead "#!/bin/perl\r\n"
  1215.         set filterHeadLen 2
  1216.     }
  1217.         
  1218.     set script $filterHead
  1219.     append script $coreScript
  1220.     
  1221.     # for debugging purposes, save the script on disk
  1222.     #
  1223.     writeScript $script
  1224.     return $script
  1225. }        
  1226.  
  1227. #############################################################################
  1228. #  Add a #!/bin/perl line to the script if it doesn't contain one already.
  1229. #  (MacPerl puts up dialog if this line is missing when it expects it,
  1230. #  hanging the DoScript and leaving us stuck.)
  1231. #
  1232. proc wrapSelectScript {coreScript} {
  1233.     global scriptStart filterHeadLen interpPat
  1234.  
  1235.     if {[regexp -indices $interpPat $coreScript allofit cmdln]} {
  1236.         set endPos [lindex $cmdln 1]
  1237.         set filterHead [string range $coreScript 0 [expr $endPos+1]]
  1238.         set script $coreScript
  1239.         set filterHeadLen 0
  1240.         incr scriptStart [expr [llength [split $filterHead "\n\r"]] -2]
  1241.     } else {
  1242.         set script "#!/bin/perl\r\n"
  1243.         append script $coreScript
  1244.         set filterHeadLen 1
  1245.     }
  1246.     
  1247.     # for debugging purposes, save the script on disk
  1248.     #
  1249.     writeScript $script
  1250.     return $script
  1251. }        
  1252.  
  1253. #############################################################################
  1254. #  Paste result of the filter operation in place of the input text, or in
  1255. #  a new window (depending on the flag $perlOverwrite
  1256. #
  1257. proc pasteFilterResult {text} {
  1258.     global perlOverwrite perlRecycleOutput perlOutputWindow
  1259.     global perlUsebuffer 
  1260.     
  1261.     if {!$perlOverwrite} {
  1262.         if {$perlRecycleOutput && 
  1263.             [lsearch [winNames] $perlOutputWindow] >= 0} {                
  1264.             bringToFront $perlOutputWindow
  1265.         } else {
  1266.             new -n $perlOutputWindow
  1267.         }
  1268.     }
  1269.     
  1270.     if {$perlUsebuffer || $perlRecycleOutput} {
  1271.         set from 0
  1272.         set to [maxPos]
  1273.     } else {
  1274.         set from [getPos] 
  1275.         set to [selEnd]
  1276.     }    
  1277.     replaceText $from $to $text
  1278.     
  1279.     if {!$perlOverwrite || $perlUsebuffer} {
  1280.         catch {shrinkWindow 2}
  1281.         goto 0
  1282.     } else {
  1283.         catch shrinkWindow
  1284.         goto $from
  1285.     }
  1286.     if {!$perlOverwrite} { setWinInfo dirty 0 }
  1287. }    
  1288.  
  1289. #############################################################################
  1290. #  Extend the current selection to encompass complete lines.  If the 
  1291. #  'applyToBuffer' flag is checked, then the entire buffer is selected.
  1292. #
  1293. proc completeSelection {} {
  1294.     global perlUsebuffer filterInput
  1295.     set filterInput "buffer \"[lindex [winNames] 0]\""
  1296.     if {$perlUsebuffer} {
  1297.         set start 0
  1298.         set end [maxPos]
  1299.     } else {
  1300.         set start [lineStart [getPos]]
  1301.         set end [nextLineStart [expr [selEnd]-1]]
  1302.         if {$end == $start} { set end [nextLineStart [selEnd]] }
  1303.         
  1304.         set startLine [lindex [posToRowCol $start] 0]
  1305.         set endLine [expr [lindex [posToRowCol $end] 0] - 1]
  1306.         if {$endLine > $startLine+1} {
  1307.             set filterInput "lines $startLine to $endLine of $filterInput"
  1308.         } else {
  1309.             set filterInput "line $startLine of $filterInput"
  1310.         }
  1311.    }
  1312.     return [list $start $end]
  1313. }
  1314.  
  1315. #############################################################################
  1316. #  writeStdin: Extend the selection, as appropriate, and write it to the 
  1317. #     STDIN file in the MacPerl directory.
  1318. #
  1319. #  writeScript: Write the SCRIPT file in the MacPerl directory.  MacPerl will
  1320. #     read the script from this file. 
  1321. #
  1322. proc writeStdin {} {
  1323.     set res [completeSelection]
  1324.     set tmpfid [open [stdinPath] "w+"]
  1325.     puts $tmpfid [eval getText $res]
  1326.     close $tmpfid
  1327. }
  1328.  
  1329. # This is unnecessary now, but maybe it'll still useful to save the script
  1330. # file for debugging.
  1331. #
  1332. proc writeScript {script} {
  1333.     set tmpfid [open [scriptPath] "w+"]
  1334.     puts $tmpfid $script 
  1335.     close $tmpfid
  1336. }
  1337.  
  1338. #############################################################################
  1339. # Read the MacPerl output window and load the contents, if any, into
  1340. # a new Alpha window. 
  1341. #
  1342. proc openPerlOutput {} {
  1343.     global perlRecycleOutput perlOutputWindow perlName
  1344.     
  1345.     set output [sendGetText $perlName $perlName]
  1346.     if {[string length $output]} {
  1347.         if {$perlRecycleOutput && 
  1348.             [lsearch [winNames] $perlOutputWindow] >= 0} {
  1349.             
  1350.             bringToFront $perlOutputWindow
  1351.             replaceText 0 [maxPos] $output
  1352.         } else {
  1353.             new -n $perlOutputWindow
  1354.             insertText $output
  1355.         }
  1356.         catch {shrinkWindow 2}
  1357.         setWinInfo dirty 0
  1358.         goto 0
  1359.     }
  1360. }
  1361.  
  1362. #############################################################################
  1363. # translate special DoScript flags into flags string $usrf
  1364. #
  1365. proc perlScriptFlags {{flags {}}} {
  1366.      set usrf {}
  1367.  
  1368.     if {[lsearch -exact $flags "extract"] >= 0} {
  1369.         append usrf { "EXTR" 'true'}
  1370.     } elseif {[lsearch -exact $flags "noextract"] >= 0} {
  1371.         append usrf { "EXTR" 'fals'}
  1372.     }        
  1373.     if {[lsearch -exact $flags "debug"] >= 0} {
  1374.         append usrf { "DEBG" 'true'}
  1375.     } elseif {[lsearch -exact $flags "nodebug"] >= 0} {
  1376.         append usrf { "DEBG" 'fals'}
  1377.     }        
  1378.  
  1379.     if {[lsearch -exact $flags "local"] >= 0} {
  1380.         append usrf { "MODE" 'LOCL'}
  1381.     } elseif {[lsearch -exact $flags "batch"] >= 0} {
  1382.         append usrf { "MODE" 'BATC'}
  1383.     } elseif {[lsearch -exact $flags "remote"] >= 0} {
  1384.         append usrf { "MODE" 'RCTL'}
  1385.     }        
  1386.     return $usrf
  1387. } 
  1388.  
  1389. proc perlScriptArgs {{args {}} {fileargs {}}} {
  1390.     set nargs 0
  1391.     set argv {}
  1392.     
  1393.     foreach item [parseWords $args] {
  1394.         set item [string trim $item]
  1395.         if {[string length $item]} {
  1396.             append argv ", [curlyq $item]"
  1397.             incr nargs
  1398.         }
  1399.     }
  1400.     foreach filename $fileargs {
  1401.         set item [string trim $filename]
  1402.         if {[string length $item]} {
  1403.             append argv ", [curlyq $item]"
  1404.             incr nargs
  1405.         }
  1406.     }
  1407.     return $argv
  1408. }
  1409.  
  1410. #############################################################################
  1411. # General Apple Event routines
  1412. # (most of these have been moved to Modes:appleEvents.tcl)
  1413. #
  1414. # DoScript for MacPerl 4.1.3
  1415. # (runs in "Local" mode under v4.1.4+)
  1416. #
  1417. proc perlDoScript {appname script {args {}} {fileargs {}} {flags {}} } {
  1418.     # form list of quoted "command-line" args
  1419.     #
  1420.     if {$script != ""} {
  1421.         set argv "\[[curlyq [string trim $script]]"
  1422. #         foreach item [split [join $args " "] " "] {
  1423. #}
  1424.         append argv [perlScriptArgs $args $fileargs]
  1425.         append argv "]"
  1426.         
  1427.         set usrf [perlScriptFlags $flags]
  1428.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc $usrf \"----\" [list $argv] "]
  1429.     #    alertnote $reply
  1430.     }
  1431. }
  1432.  
  1433. # DoScript for MacPerl 4.1.4+
  1434. #
  1435. proc perlDoScriptBatch {appname script {args {}} {fileargs {}}} {
  1436.     
  1437.     # form list of quoted "command-line" args
  1438.     #
  1439.     if {$script != ""} {
  1440.         set argv "\[[curlyq [string trim $script]]"
  1441.         append argv [perlScriptArgs $args $fileargs ] 
  1442.         append argv "]"
  1443.                 
  1444.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc MODE BATC \"----\" [list $argv]"]
  1445.         
  1446. #         perlDisplayReply $reply
  1447.  
  1448.     } else {
  1449.         set reply {}
  1450.     }
  1451.     return $reply
  1452. }
  1453.  
  1454. # For debugging 
  1455. #
  1456. proc perlDisplayReply {reply} {
  1457.     set currWin [lindex [winNames] 0]
  1458.     new -n {*** DoScript Reply **} 
  1459.     insertText $reply
  1460.         
  1461.     goto 0
  1462.     catch {shrinkWindow 2}
  1463.     setWinInfo dirty 0
  1464.     setWinInfo read-only 1
  1465.     bringToFront $currWin
  1466. }
  1467.  
  1468. # DoScript to launch interactive debugger (for MacPerl 4.1.4+)
  1469. #
  1470. proc perlDoScriptDebug {appname script {args {}} {fileargs {}}} {
  1471.     
  1472.     # form list of quoted "command-line" args
  1473.     #
  1474.     if {$script != ""} {
  1475.         set argv "\[[curlyq [string trim $script]]"
  1476.         append argv [perlScriptArgs "$args debug" $fileargs ] 
  1477.         append argv "]"
  1478.                 
  1479.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc MODE RCTL \"----\" [list $argv]"]
  1480.  
  1481.         new -n {** DoScriptDebug Reply **} 
  1482.         insertText $reply
  1483.             
  1484.         goto 0
  1485.         catch {shrinkWindow 2}
  1486.         setWinInfo dirty 0
  1487.         setWinInfo read-only 1
  1488.  
  1489.  
  1490.     } else {
  1491.         set reply {}
  1492.     }
  1493.     return $reply
  1494. }
  1495.  
  1496. ##############################################################################
  1497. # Automatic indexing of Perl subs
  1498. #
  1499. proc PerlMarkFile {} {
  1500.     set end [maxPos]
  1501.     set pos 0
  1502.     set l {}
  1503.     while {![catch {search -f 1 -r 1 -m 0 -i 0 {^sub} $pos} res]} {
  1504.         set start [lindex $res 0]
  1505.         set end [nextLineStart $start]
  1506.         set text [lindex [getText $start $end] 1]
  1507.         set pos $end
  1508.         set inds($text) [lineStart [expr $start - 1]]
  1509.     }
  1510.  
  1511.     if {[info exists inds]} {
  1512.         foreach f [lsort [array names inds]] {
  1513.             set next [nextLineStart $inds($f)]
  1514.             setNamedMark $f $inds($f) $next $next
  1515.         }
  1516.     }
  1517. }
  1518.  
  1519.  
  1520. # Open a 'require'd Perl file.
  1521. # 
  1522. proc perlFindRequire {from {to 0}} {
  1523.     set reqPat {^[     ]*require[     ]*(\"[^\"]+\"|\'[^\']+\'|[^     ]+)}
  1524.     if {$to == 0} { set to $from }
  1525.     set beg [lineStart $from]
  1526.     set end [nextLineStart $to]
  1527.     set words [parseWords [getText $beg $end]]
  1528.     if {[string tolower [lindex $words 0]] != "require"} {
  1529.         error "Not a require statement"
  1530.     }
  1531.     set root [string trim [lindex $words 1] {'"}]
  1532.     return $root
  1533. }
  1534.  
  1535. proc inlineRequires {} {
  1536.     global lastMatchingLines
  1537.     
  1538.     set reqPat {^[     ]*require[     ]*(\"[^\"]+\"|\'[^\']+\'|[^     ]+)}
  1539.     set pos 0
  1540.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $reqPat $pos} mtch]} {
  1541.          [lindex [posToRowCol [lindex $mtch 0]] 0]] 
  1542.         set name [string [eval getText $mtch]
  1543.         set pos [lindex $mtch 1]
  1544.         incr matches
  1545.     }
  1546. }
  1547.  
  1548. # Open a Perl source file. 
  1549. #
  1550. proc openPerlFile {file {extensions {""}}} {
  1551.     global perlSearchPath
  1552.     # Determine absolute file specification
  1553.     # Ignore $extensions if $file already has an extension
  1554.     if {[string length [file extension $file]] == 0} {
  1555.         set extensions {""}
  1556.     }
  1557.     foreach ext $extensions {
  1558.         set filename [absolutePath $file$ext]
  1559.         if {![catch {openFileQuietly $filename}]} {
  1560.             message $filename
  1561.             return 
  1562.         }
  1563.     }
  1564.     if {[llength $perlSearchPath] == 0} { buildPerlSearchPath }
  1565.     foreach folder $perlSearchPath {
  1566.         foreach ext $extensions {
  1567.             set filename "$folder$file$ext"
  1568.             if {![catch {openFileQuietly $filename}]} {
  1569.                 message $filename
  1570.                 return     
  1571.             }
  1572.         }
  1573.     }
  1574.     beep
  1575.     message "can't find Perl source file \"$file\""
  1576. }
  1577.  
  1578. # Return a list of folders in which to search for Perl library files, 
  1579. # including the lib folder in the Perl application directory and the
  1580. # $perlLib folder (if it exists) .  
  1581. # The current folder is not included in the list.
  1582. #
  1583. # (The $perlLib folder is assigned from the AppPaths submenu.)
  1584. #
  1585. proc buildPerlSearchPath {} {
  1586.     global perlLib perlSearchPath
  1587.     message "building Perl search path..."
  1588.     set folders {}
  1589.     
  1590.     # The local lib folder:
  1591.     if {[info exists perlLib] && [string length $perlLib] > 0} { 
  1592.         set folders [concat $folders [list $perlLib]]
  1593.         # Search subfolders one level deep:
  1594.         set folders [concat $folders [listSubfolders $perlLib 1]]
  1595.     }
  1596.  
  1597.     # Any "*lib*" folders in the MacPerl application folder:
  1598.     set macperlPath [nameFromAppl McPL]
  1599.     set appDir [file dirname $macperlPath]
  1600.     set folders [concat $folders [list $appDir]]
  1601.     # Bug:  'glob' is case sensitive!
  1602.     foreach folder [glob "$appDir:*\[Ll\]ib*"] {
  1603.         set folders [concat $folders [list $folder]]
  1604.         # Search subfolders one level deep:
  1605.         set folders [concat $folders [listSubfolders $folder 1]]
  1606.     }
  1607.  
  1608.     # Make sure each folder ends with a colon
  1609.     set perlSearchPath {}
  1610.     foreach folder $folders {
  1611.         set folder "[string trimright $folder {:}]:"
  1612.         set perlSearchPath [concat $perlSearchPath [list $folder]]
  1613.     }
  1614. }
  1615.  
  1616. ###########################################################################
  1617. #
  1618. proc perlHelpProc {menu item} {
  1619.     global HOME perlDocs
  1620.     switch $item {
  1621.         "MacPerl Mode"    {
  1622.                 if {[catch {openFileQuietly "$HOME:Help:MacPerl Help"}]} {
  1623.                     alertnote "File not found:\r$HOME:Help:MacPerl Help"
  1624.                 }
  1625.             }
  1626.         "Mac Specifics"    {
  1627.                 if {[catch {openFileQuietly "$HOME:Help:MacPerl.Specifics"}]} {
  1628.                     alertnote "File not found:\r$HOME:Help:MacPerl.Specifics"
  1629.                 }
  1630.             }
  1631.         "Perl4 Manual"    {
  1632.                 if {[catch {openFileQuietly "$HOME:Help:Perl Commands"}]} {
  1633.                     alertnote "File not found:\r$HOME:Help:Perl Commands"
  1634.                 }
  1635.             }
  1636.         "Perl5 Manual"    {
  1637.                 catch {editMark "$HOME:Help:Perl Commands" Perl5 -r}
  1638.             }
  1639.     }
  1640. }
  1641.  
  1642. proc electricPerlLeft {} {
  1643.     set prevChar [lookAt [expr [getPos] - 1]]
  1644.     if {$prevChar == " " || $prevChar == "\)"} {
  1645.         electricLeft
  1646.         return
  1647.     }
  1648.     deleteText [getPos] [selEnd]
  1649.     insertText "\{"
  1650. }
  1651.  
  1652. proc electricPerlRight {} {
  1653.     set prevChar [lookAt [expr [getPos] - 1]]
  1654.     if {$prevChar == " " || $prevChar == ";" || $prevChar == "\t" || $prevChar == "\}"} {
  1655.         electricRight
  1656.         return
  1657.     }
  1658.     deleteText [getPos] [selEnd]
  1659.     insertText "\}"
  1660.     catch {blink [matchIt "\}" [expr [getPos]-2]]}
  1661.     return
  1662. }
  1663.  
  1664. bind '\r' tclCarriageReturn Perl
  1665. bind '\}' <s> electricPerlRight Perl
  1666. bind '\{' <s> electricPerlLeft Perl
  1667. bind '\;' electricSemi Perl
  1668. bind '\t' <z> doATab Perl
  1669.  
  1670. #
  1671.  
  1672.